home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / PNL Libraries / MyStandardFile.p < prev    next >
Encoding:
Text File  |  1994-08-27  |  6.5 KB  |  243 lines  |  [TEXT/PJMM]
  1. unit MyStandardFile;
  2.  
  3. interface
  4.  
  5.     type
  6.         MySFReply = record
  7.                 Rgood: boolean;
  8.                 Rfolder: boolean;
  9.                 RfType: OSType;
  10.                 RvRefNum: integer;
  11.                 RdirID: longInt;
  12.                 RfName: str63;
  13.             end;
  14.  
  15.     function MFSPt: point;
  16.     procedure GetFile (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; var reply: MySFReply);
  17.     procedure GetFile1 (t: OSType; var reply: MySFReply);
  18.     procedure GetFolder (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; id: integer; var reply: MySFReply);
  19. { NOTE: GetFolder must be passed a Dialog ID with Button 11 being a folder button }
  20. { NOTE: reply.copy should be interpreted as reply.folder }
  21.     procedure PutFile (str, origName: str255; var reply: MySFreply);
  22.     procedure PutFolder (str, origName: str255; id: integer; var reply: MySFreply);
  23. { NOTE: PutFolder must be passed a Dialog ID with Button 9 being a folder button }
  24. { NOTE: reply.copy should be interpreted as reply.folder }
  25.     function Button11Hook (item: integer; dlg: DialogPtr): integer;
  26. { NOTE: Button11Hook sets Button11 when it converts Button 11 to Button 1 (Open) }
  27.     function Button9Hook (item: integer; dlg: DialogPtr): integer;
  28. { NOTE: Button9Hook sets Button9 when it converts Button 9 to Button 1 (Save) }
  29.     procedure SetSFFile (wdrn: integer; dirID: longInt);
  30.     procedure SegmentStandardFile;
  31.  
  32. implementation
  33.  
  34.     uses
  35.         MyTypes, MyUtils, MySystemGlobals, MyButtons;
  36.  
  37.  {$S StandardFile}
  38.     procedure SegmentStandardFile;
  39.     begin
  40.     end;
  41.  
  42.     procedure SetSFFile (wdrn: integer; dirID: longInt);
  43.         var
  44.             oe: OSErr;
  45.             vrn: integer;
  46.             procID: longInt;
  47.     begin
  48.         if dirID = 0 then
  49.             oe := GetWDInfo(wdrn, vrn, dirID, procID)
  50.         else
  51.             vrn := wdrn;
  52.         integerP(SFSaveDiskA)^ := -vrn;
  53.         longIntP(CurDirStoreA)^ := dirID;
  54.     end;
  55.  
  56.     function MFSPt: point;
  57.         var
  58.             pt: point;
  59.     begin
  60.         pt.v := 40;
  61.         pt.h := 40;
  62.         MFSPt := pt;
  63.     end;
  64.  
  65.     procedure SetStdReply (var reply: MySFReply; stdReply: StandardFileReply);
  66.     begin
  67.         with reply do begin
  68.             Rgood := stdReply.sfGood;
  69.             Rfolder := ord(stdReply.sfIsFolder) <> 0;        { Argghhh!  Bloody Apple and there C booleans! }
  70.             RfType := stdReply.sfType;
  71.             RvRefNum := stdReply.sfFile.vRefNum;
  72.             RdirID := stdReply.sfFile.parID;
  73.             RfName := stdReply.sfFile.name;
  74.         end;
  75.     end;
  76.  
  77.     procedure SetOldReply (var reply: MySFReply; oldReply: SFReply);
  78.         var
  79.             oe: OSErr;
  80.     begin
  81.         with reply do begin
  82.             Rgood := oldReply.good;
  83.             Rfolder := oldReply.copy;
  84.             RfType := oldReply.fType;
  85.             oe := GetDirID(oldReply.vRefNum, RvRefNum, RdirID);
  86.             RfName := oldReply.fName;
  87.         end;
  88.     end;
  89.  
  90.     procedure GetFile (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; var reply: MySFReply);
  91.         var
  92.             stdReply: StandardFileReply;
  93.             oldReply: SFReply;
  94.     begin
  95.         with reply do
  96.             if has_newStdFile then begin
  97.                 StandardGetFile(ffilter, numTypes, typeList, stdReply);
  98.                 SetStdReply(reply, stdReply);
  99.             end
  100.             else begin
  101.                 SFGetFile(MFSPt, '', ffilter, numTypes, typeList, nil, oldReply);
  102.                 oldReply.copy := false;
  103.                 SetOldReply(reply, oldReply);
  104.             end;
  105.     end;
  106.  
  107.     procedure GetFile1 (t: OSType; var reply: MySFReply);
  108.         var
  109.             typeList: SFTypeList;
  110.     begin
  111.         if t = OSType(noType) then
  112.             GetFile(nil, -1, typeList, reply)
  113.         else begin
  114.             typeList[0] := t;
  115.             GetFile(nil, 1, typeList, reply);
  116.         end;
  117.     end;
  118.  
  119.     procedure PutFile (str, origName: str255; var reply: MySFreply);
  120.         var
  121.             stdReply: StandardFileReply;
  122.             oldReply: SFReply;
  123.     begin
  124.         with reply do
  125.             if has_newStdFile then begin
  126.                 StandardPutFile(str, origName, stdReply);
  127.                 SetStdReply(reply, stdReply);
  128.             end
  129.             else begin
  130.                 SFPutFile(MFSPt, str, origName, nil, oldReply);
  131.                 oldReply.copy := false;
  132.                 SetOldReply(reply, oldReply);
  133.             end;
  134.     end;
  135.  
  136.     var
  137.         oldReply: SFReply;
  138.         newReply: StandardFileReply;
  139. { item1 is ThisFolder }
  140.         item1: integer;
  141.         button1: boolean;
  142.         active1: boolean;
  143.  
  144.     procedure SetButtons (dlg: dialogPtr);
  145.         var
  146.             new1: boolean;
  147.     begin
  148.         if has_newStdFile then begin
  149.             new1 := newReply.sfFile.parID <> 1; { everywhere except  desktop???? }
  150.         end
  151.         else begin
  152.             new1 := true;
  153.         end;
  154.         SetButton(dlg, item1, active1, new1);
  155.     end;
  156.  
  157.     function ButtonModalFilter (dlg: dialogPtr; var er: eventRecord; var item: integer): boolean;
  158.     begin
  159.         SetButtons(dlg);
  160.         if (er.what = updateEvt) and (dlg = dialogPtr(er.message)) then begin
  161.             UpdateButton(dlg, item1, active1);
  162.         end;
  163.         ButtonModalFilter := false;
  164.     end;
  165.  
  166.     function ButtonModalFilterSys7 (dlg: dialogPtr; var er: eventRecord; var item: integer; data: ptr): boolean;
  167.     begin
  168.         ButtonModalFilterSys7 := ButtonModalFilter(dlg, er, item);
  169.     end;
  170.  
  171.     function ButtonHook (item: integer; dlg: DialogPtr): integer;
  172.     begin
  173.         if not has_newStdFile or (GetWRefCon(dlg) = longint(sfMainDialogRefCon)) then begin
  174.             if item = sfHookFirstCall then begin
  175.                 button1 := false;
  176.                 InitButton(dlg, item1, active1, active1);
  177.                 SetButtons(dlg);
  178.             end;
  179.             if active1 then begin
  180.                 if item <> sfHookLastCall then begin
  181.                     button1 := item = item1;
  182.                     if button1 then
  183.                         item := sfItemOpenButton;
  184.                 end;
  185.             end;
  186.         end;
  187.         ButtonHook := item;
  188.     end;
  189.  
  190.     function ButtonHookSys7 (item: integer; dlg: DialogPtr; data: ptr): integer;
  191.     begin
  192.         ButtonHookSys7 := ButtonHook(item, dlg);
  193.     end;
  194.  
  195.     procedure PutFolder (str, origName: str255; id: integer; var reply: MySFreply);
  196.     begin
  197.         if has_newStdFile then begin
  198.             item1 := 13;
  199.             active1 := true;
  200.             CustomPutFile(str, origName, newReply, id + 1, MFSPt, @ButtonHookSys7, @ButtonModalFilterSys7, nil, nil, nil); {@ButtonModalFilterSys7}
  201.             SetStdReply(reply, newReply);
  202.             reply.Rfolder := button1;
  203.         end
  204.         else begin
  205.             item1 := 9;
  206.             active1 := true;
  207.             SFPPutFile(MFSPt, str, origName, @ButtonHook, oldReply, id, nil);
  208.             oldReply.copy := button1;
  209.             SetOldReply(reply, oldReply);
  210.         end;
  211.     end;
  212.  
  213.     function CallFileFilterSys7 (pb: CInfoPBPtr; addr: ptr): boolean;
  214.     inline
  215.         $205F, $4E90;
  216.  
  217.     function FileFilterSys7 (pb: CInfoPBPtr; addr: ptr): boolean;
  218.     begin
  219.         if (BAND(pb^.ioFlAttrib, $0010) = 0) and (addr <> nil) then
  220.             FileFilterSys7 := CallFileFilterSys7(pb, addr)
  221.         else
  222.             FileFilterSys7 := false;
  223.     end;
  224.  
  225.     procedure GetFolder (ffilter: Ptr; numTypes: integer; typeList: SFTypeList; id: integer; var reply: MySFReply);
  226.     begin
  227.         if has_newStdFile then begin
  228.             item1 := 10;
  229.             active1 := true;
  230.             CustomGetFile(@FileFilterSys7, numTypes, typeList, newReply, id + 1, MFSpt, @ButtonHookSys7, @ButtonModalFilterSys7, nil, nil, ffilter);
  231.             SetStdReply(reply, newReply);
  232.             reply.Rfolder := button1;
  233.         end
  234.         else begin
  235.             item1 := 11;
  236.             active1 := true;
  237.             SFPGetFile(MFSPt, '', ffilter, numTypes, typeList, @ButtonHook, oldReply, id, nil);
  238.             oldReply.copy := button1;
  239.             SetOldReply(reply, oldReply);
  240.         end;
  241.     end;
  242.  
  243. end.